home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / defs.em < prev    next >
Lisp/Scheme  |  1992-06-18  |  12KB  |  386 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;  EuLisp Module                     Copyright (C) University of Bath 1991  ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;                                                                           ;;
  9. ;; Name: defs                                                                ;;
  10. ;;                                                                           ;;
  11. ;; Author: Keith Playford                                                    ;;
  12. ;;                                                                           ;;
  13. ;; Date: 21 August 1990                                                      ;;
  14. ;;                                                                           ;;
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16.  
  17. ;;
  18.  
  19. ;; Change Log:
  20. ;;   Version 1.0 (21/8/90)
  21.  
  22. ;;
  23.  
  24. ;; Lisp version of defclass... */
  25.  
  26. (defmodule defs
  27.  
  28.   (lists ccc calls list-operators arith 
  29.    (except (defcondition) errors )
  30.    symbols others macros0 extras0
  31.    (except (defclass defstruct) classes)
  32.    (except (null) class-names)
  33.    
  34.    streams)
  35.  
  36.   ()
  37.  
  38.  
  39.   ;; 'defstruct'...
  40.  
  41.   ;; Utils... 
  42.  
  43.   (defconstant *key-list-fail* nil)
  44.  
  45.   (defconstant *nothing* (gensym))
  46.  
  47.   (defun search-key-list (l k)
  48.     (cond ((null l) *key-list-fail*)
  49.       ((eqcar l k) (cadr l))
  50.       (t (search-key-list (cddr l) k))))
  51.  
  52.   (defconstant invalid-slot-options
  53.     (make-instance condition-class
  54.        'name 'invalid-slot-options
  55.        'direct-superclasses (list condition)
  56.        'direct-slot-descriptions
  57.           `((name options 
  58.              initargs (options) 
  59.              initform ,(lambda () ()) 
  60.              slot-class ,local-slot-description))))
  61.  
  62.   (deflocal *name* nil)
  63.   (deflocal *readers* nil)
  64.   (deflocal *writers* nil)
  65.   (deflocal *accessors* nil)
  66.  
  67.   (defun reset ()
  68.     (setq *name* nil)
  69.     (setq *readers* nil)
  70.     (setq *writers* nil)
  71.     (setq *accessors* nil))
  72.  
  73.   (defun canonicalise (ops def-slot-class)
  74.     (when (symbolp ops) (setq ops (list ops)))
  75.     (unless (consp ops) (error "slot options not a list"
  76.                      invalid-slot-options 'options ops))
  77.     (let ((name *nothing*)
  78.       (slot-class def-slot-class)
  79.       (slot-initargs *nothing*)
  80.       (initform *nothing*)
  81.       (initargs nil)
  82.       (readers nil)
  83.       (writers nil)
  84.       (accessors nil))
  85.       (labels
  86.        ((inner (l)
  87.            (unless (null l) 
  88.                (let ((key (car l)) 
  89.                  (val (cadr l)))
  90.              (cond ((eq key 'initarg)
  91.                 (setq initargs (nconc initargs (list val))))
  92.                    ((eq key 'initform)
  93.                 (if (eq initform *nothing*)
  94.                     (setq initform `(lambda () ,val))
  95.                   (error "bad initform"
  96.                      invalid-slot-options 'options ops)))
  97.                    ((eq key 'slot-class) 
  98.                 (if (eq slot-class def-slot-class)
  99.                     (setq slot-class   val);;do find-dbclass of val
  100.                   (error "slot-class multiply defined"
  101.                      invalid-slot-options 'options ops)))
  102.                    ((eq key 'slot-initargs)
  103.                 (if (eq slot-initargs *nothing*)
  104.                     (setq slot-initargs val);; was class-initargs
  105.                   (error "slot initargs multiply defined"
  106.                      invalid-slot-options 'options ops)))
  107.                    ((eq key 'reader)
  108.                 (setq readers (cons (cons val name) readers)))
  109.                    ((eq key 'writer)
  110.                 (setq writers (cons (cons val name) writers)))
  111.                    ((eq key 'accessor)
  112.                 (setq accessors (cons (cons val name) accessors)))
  113.                    (t (error "unknown slot option"
  114.                      invalid-slot-options 'options ops))))
  115.                (inner (cddr l)))))
  116.        (setq name (car ops))
  117.        (inner (cdr ops))
  118.        (setq *readers* (nconc readers *readers*))
  119.        (setq *writers* (nconc writers *writers*))
  120.        (setq *accessors* (nconc accessors *accessors*))
  121.        (when (eq slot-class *nothing*) 
  122.          (setq slot-class 'local-slot-description))
  123.        (when (eq slot-initargs *nothing*)
  124.          (setq slot-initargs nil))
  125.        (nconc `(list 'name          ',name 
  126.              'slot-class    ,slot-class 
  127.              ,@slot-initargs
  128.              'initargs      ',initargs)
  129.           (if (eq initform *nothing*) nil `('initform ,initform))))))
  130.   
  131.   (defun reader-defs (o) 
  132.     (mapcar 
  133.       (lambda (pair) 
  134.     `(defconstant ,(car pair) (make-reader ,*name* ',(cdr pair))))
  135.       *readers*))
  136.  
  137.   (defun writer-defs (o) 
  138.     (mapcar 
  139.       (lambda (pair) 
  140.     `(defconstant ,(car pair) (make-writer ,*name* ',(cdr pair))))
  141.       *writers*))
  142.  
  143.   (defun accessor-defs (o) 
  144.     (mapcar 
  145.       (lambda (pair) 
  146.     `(progn
  147.        (defconstant ,(car pair) (make-reader ,*name* ',(cdr pair)))
  148.        ((setter setter) ,(car pair) (make-writer ,*name* ',(cdr pair)))))
  149.       *accessors*))
  150.  
  151.   (defun make-constructor-initarg-list (ll)
  152.     (if (not (consp ll)) ()
  153.       (cons (list 'quote (car ll))
  154.         (cons (car ll) (make-constructor-initarg-list (cdr ll))))))
  155.  
  156.   (defun improper-list-p (l)
  157.     (if (not (consp l)) l (improper-list-p (cdr l))))
  158.  
  159.   (defun make-positional-constructor-def (spec)
  160.     (let* ((name (car spec))
  161.        (ll (cdr spec))
  162.        (tail (improper-list-p ll)))
  163.       (if (null tail)
  164.     `(defun ,name ,ll
  165.        (make-instance ,*name*
  166.               ,@(make-constructor-initarg-list ll)))
  167.     `(defun ,name ,ll
  168.        (apply
  169.          make-instance
  170.          ,*name*
  171.          (nconc (list ,@(make-constructor-initarg-list ll)) ,tail))))))
  172.     
  173.   (defun constructor-defs (o)
  174.     (cond ((null o) nil)
  175.       ((null (cdr o)) (error "unbalance class ops" 
  176.                  invalid-slot-options 'options o))
  177.       ((eqcar o 'constructor)
  178.         (let ((spec (car (cdr o))))
  179.           (if (not (consp spec))
  180.         (cons (make-positional-constructor-def (cons spec 'args))
  181.               (constructor-defs (cddr o)))
  182.         (cons (make-positional-constructor-def spec)
  183.               (constructor-defs (cddr o))))))
  184.       ((eqcar o 'predicate)
  185.         (cons `(progn
  186.              (defgeneric ,(car (cdr o)) (obj))
  187.              (defmethod ,(car (cdr o)) ((obj object)) ())
  188.              (defmethod ,(car (cdr o)) ((obj ,*name*)) obj))
  189.           (constructor-defs (cddr o))))
  190.       (t (constructor-defs (cddr o)))))
  191.  
  192.   (defun quotify-alternate (l)
  193.     (if (null l) ()
  194.       (cons (list 'quote (car l)) 
  195.         (cons (car (cdr l)) 
  196.           (quotify-alternate (cdr (cdr l)))))))
  197.  
  198.   (defun metaclass-initargs (ops)
  199.     (let ((args (search-key-list ops 'metaclass-initargs)))
  200.       (unless (eq args *key-list-fail*)
  201.     (quotify-alternate args))))
  202.       
  203.   (defmacro defstruct (name super slot-ops . class-ops)
  204.     (reset)
  205.     (setq *name* name)
  206.     `(progn
  207.        (defconstant ,name
  208.      (make-instance structure-class
  209.        'name ',name
  210.        'direct-superclasses ,(if super `(list ,super) '(list structure)) 
  211.        'direct-slot-descriptions
  212.          (list ,@(mapcar (lambda (x) (canonicalise x 'local-slot-description))
  213.                  slot-ops))
  214.        'metaclass-hypotheses nil))
  215.        ,@(reader-defs slot-ops)
  216.        ,@(writer-defs slot-ops)
  217.        ,@(accessor-defs slot-ops)
  218.        ,@(constructor-defs class-ops)
  219.        ',name))
  220.  
  221.   (export defstruct)
  222.  
  223.   (defmacro defclass (name supers slot-ops . class-ops)
  224.     (reset)
  225.     (setq *name* name)
  226.     (let ((metaclass
  227.         (or (search-key-list class-ops 'metaclass) 'class))
  228.       (initargs 
  229.         (or (search-key-list class-ops 'metaclass-initargs) nil))
  230.       (slot-class (or (search-key-list class-ops 'default-slot-class) 
  231.               'local-slot-description)))
  232.       `(progn
  233.      (defconstant ,name
  234.        (make-instance ,metaclass
  235.          'name ',name
  236.          'direct-superclasses ,(if supers `(list ,@supers) '(list object))
  237.          'direct-slot-descriptions
  238.            (list ,@(mapcar (lambda (x) (canonicalise x slot-class))
  239.                    slot-ops))
  240.          'metaclass-hypotheses ()
  241.          ,@(metaclass-initargs class-ops)))
  242.      ,@(reader-defs slot-ops)
  243.      ,@(writer-defs slot-ops)
  244.      ,@(accessor-defs slot-ops)
  245.      ,@(constructor-defs class-ops)
  246.      ',name)))
  247.  
  248.   (export defclass)
  249.  
  250.   (defmacro defreader (name class slot)
  251.     `(defconstant ,name (make-reader ,class ',slot)))
  252.  
  253.   (defmacro defwriter (name class slot)
  254.     `(defconstant ,name (make-writer ,class ',slot)))
  255.  
  256.   (defmacro defaccessor (name class slot)
  257.     `(progn
  258.        (defconstant ,name (make-reader ,class ',slot))
  259.        ((setter setter) ,name (make-writer ,class ',slot))))
  260.  
  261.   (defmacro defpredicate (name class)
  262.     `(progn
  263.        (defgeneric ,name (x))
  264.        (defmethod ,name ((x object)) ())
  265.        (defmethod ,name ((x ,class)) x)))
  266.  
  267.   (export defreader defwriter defaccessor defpredicate)
  268.  
  269.   (defun method-extra-args ()
  270.     (if (compile-time-p)
  271.     ()
  272.       (list '***method-status-handle*** '***method-args-handle***)))
  273.  
  274.   (defun sll-signature (ll)
  275.     (cond ((not (consp ll)) nil)
  276.       ((consp (car ll)) (cons (cadar ll) (sll-signature (cdr ll))))
  277.       (t (cons 'object (sll-signature (cdr ll))))))
  278.  
  279.   (defun sll-formals (ll)
  280.     (cond ((null ll) nil)
  281.       ((not (consp ll)) ll)
  282.       ((consp (car ll)) (cons (caar ll) (sll-formals (cdr ll))))
  283.       (t (cons (car ll) (sll-formals (cdr ll))))))
  284.  
  285.   (defun gf-class (ops)
  286.     (let ((val (search-key-list ops 'class)))
  287.       (if (eq val *key-list-fail*) 'generic-function val)))
  288.  
  289.   (defun gf-method-class (ops)
  290.     (let ((val (search-key-list ops 'method-class)))
  291.       (if (eq val *key-list-fail*) 'method val)))
  292.   
  293.   (defun gl-name (ops)
  294.     (let ((val (search-key-list ops 'name)))
  295.       (if (eq val *key-list-fail*) '*unnamed-lambda* val)))
  296.  
  297.   (defun gf-methods (ops mc)
  298.     (let ((val (search-key-list ops 'methods)))
  299.       (if (eq val *key-list-fail*) nil
  300.     `(list
  301.         ,@(mapcar
  302.             (lambda (form)
  303.               `(make-instance ,mc
  304.              'signature (list ,@(sll-signature (car form)))
  305.              'function
  306.              (lambda (,@(method-extra-args)
  307.                   ,@(sll-formals (car form)))
  308.                ,@(cdr form)))) 
  309.         val)))))
  310.  
  311.   (defmacro defgeneric (name ll . ops)
  312.     `(,@(if (symbolp name) (list 'defconstant name)
  313.       (list `(setter setter) (car (cdr name))))
  314.        (make-instance ,(gf-class ops)
  315.       'name ',name
  316.           'lambda-list ',ll
  317.       'method-class ,(gf-method-class ops)
  318.       'methods ,(gf-methods ops (gf-method-class ops)))))
  319.  
  320.   (export defgeneric)
  321.  
  322.   (defmacro defmethod (name sll . body)
  323.     `(progn
  324.        (add-method 
  325.      ,name
  326.      (make-instance (generic-function-method-class ,name)
  327.             'signature (list ,@(sll-signature sll))
  328.             'function
  329.               (lambda ,(append (method-extra-args)
  330.                        (sll-formals sll))
  331.                 ,@body)))))
  332.  
  333.   (export defmethod)
  334.  
  335.   (defun defcondition-slot-descriptions (l)
  336.     (if (null l) nil
  337.       (cons `(list 'name ',(car l) 
  338.                'slot-class local-slot-description 
  339.                    'initargs ',(list (car l))
  340.                    'initform (lambda () ,(cadr l)))
  341.         (defcondition-slot-descriptions (cddr l)))))
  342.  
  343.   (defmacro defcondition (name super . pairs)
  344.     `(defconstant ,name
  345.        (make-instance condition-class
  346.           'name ',name
  347.           'direct-superclasses (list ,(if super super 'condition))
  348.       'direct-slot-descriptions
  349.         (list ,@(defcondition-slot-descriptions pairs)))))
  350.  
  351.   (export defcondition)
  352.  
  353.    (defmacro call-next-method ()
  354.      (if (compile-time-p)
  355.      '(call-method-by-list (method-method-list) 
  356.                  (method-arg-list))
  357.        '(if  ***method-status-handle***
  358.         (progn ;;(format t "Call next: ~a ~a\n"
  359.           ;;***method-status-handle***
  360.           ;;     ***method-args-handle***)
  361.           (apply call-method-by-list
  362.              (list ***method-status-handle***
  363.                ***method-args-handle***)))
  364.       (error "No Next Method" Internal-Error nil))))
  365.  
  366.    (defmacro next-method-p ()
  367.      (if (compile-time-p)
  368.      (progn (error "Next-method-p: not implemented" clock-tick)
  369.         nil)
  370.        '***method-status-handle***))
  371.  
  372.    (export next-method-p)
  373.  
  374.   (defmacro generic-lambda (args . ops)
  375.     `(make-instance ,(gf-class ops)
  376.       'name ',(gl-name ops)
  377.           'lambda-list ',args
  378.       'method-class ,(gf-method-class ops)
  379.       'methods ,(gf-methods ops (gf-method-class ops))))
  380.  
  381.   
  382.   (export call-next-method generic-lambda)
  383.  
  384. )
  385.  
  386.